home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / prolog / ai.prl / mike1.exe / ENGINE1.PL < prev    next >
Encoding:
Text File  |  1990-09-17  |  26.9 KB  |  669 lines
  1. /* file: ENGINE1.PL {main code for MIKE rule/frame engine} */
  2. /*       see also ENGINE2.PL for more!                     */
  3. /*                          *************
  4.                                M I K E
  5.                             *************
  6.                Micro Interpreter for Knowledge Engineering
  7.                   {written in Edinburgh-syntax Prolog}
  8.  
  9. Copyright (C) 1989, 1990  The Open University (U.K.)
  10.  
  11. This software accompanies Open University Study Pack PD624, 'KNOWLEDGE
  12. ENGINEERING'.  Complete sets of study pack materials may be obtained from:
  13.  
  14.                       Learning Materials Sales Office
  15.                       The Open University
  16.                       P.O. Box 188
  17.                       Milton Keynes MK7 6DH, U.K.
  18.  
  19.                       Tel: [+44] (908) 653338
  20.                       Fax: [+44] (908) 653744
  21. */
  22. /* ENGINE1.PL & ENGINE2.PL contain the essential innards of MIKE.
  23.    Some auxilliary code is contained in the files UTIL.PL and IO.PL,
  24.    and the kernel of the forward chaining executive loop is in FC_EXEC.PL
  25.    ENGINE1.PL & ENGINE2.PL are subdivided into six main parts, as follows:
  26.    1.  Backward chaining
  27.    2.  Frame manipulation
  28.    3.  Demon processing
  29.    (N.B. the last three parts are in file ENGINE2.PL)
  30.    4.  Top level
  31.    5.  Forward chaining (left hand side conditions)
  32.    6.  Forward chaining (right hand side actions)
  33. */
  34. /* ================ (1) B A C K W A R D  C H A I N I N G =============== */
  35.  
  36. /* prove1 invokes the workhorse prove, but wraps it inside
  37.    some MIKE tracing information, settable by user request.
  38.    (Tracing is set up by a call to ?- tracing.  It is defined in UTIL.PL ) */
  39.  
  40. prove1(Goal,Depth) :-
  41.   when_enabled('show backward chaining' for Goal/Depth),
  42.   prove(Goal,Depth),
  43.   when_enabled('show outcome of backward chaining' for Goal/Depth).
  44.  
  45. prove1(Goal,Depth) :-
  46.   enabled('show outcome of backward chaining',' enabled ',_),
  47.   write('<- '),tab(Depth),write('- '),conj_write(Goal),nl,
  48.   !,
  49.   fail.
  50.  
  51. /* Top level invocation of prove (usually done via  deduce <pattern> ) */
  52. prove((A&B)) :-    /* Conjunction of goals */
  53.   !,
  54.   prove1((A&B),0).  /* set initial depth to zero */
  55.  
  56. prove(X) :-        /* Singleton goal */
  57.   prove1(X,0).     /* set initial depth to zero */
  58.  
  59. /* prove/2 is the main meta-level interpreter */
  60. /* case 1: conjunction of goals... tackle head, then rest */
  61. prove((Head & Rest),D) :-
  62.     prove1(Head,D),  /* use prove1 to invoke optional tracing info... */
  63.  (Rest = (_ & _) , prove(Rest,D);  /* Rest is conjunct? no trace */
  64.   not(Rest = (_ & _)), prove1(Rest,D)). /* Rest is singleton? prove1 trace OK */
  65.  
  66. prove((A&B),_):- !,fail. /* only arrive here if above calls fail */
  67.  
  68. /* case 2: A disjunction of goals */
  69. prove((A or B),D) :-
  70.     prove1(A,D), !.
  71. prove((_ or B),D) :-
  72.     prove1(B,D).
  73.  
  74. /* case 3, e.g. prove(the Slot of Object is Filler) is handled below
  75.   by the call to in_wm (now covered by case 6) */
  76.  
  77. /* cases 4a-4b: special traps for relational operators > and <.
  78.    The code for >= or =< is equally trivial */
  79. prove(the Slot of Object > Value,D) :-
  80.     !,
  81.     fetch(Object, Slot, Filler, [Object], _),
  82.     Filler > Value.
  83. prove(the Slot of Object < Value,D) :-
  84.     !,
  85.     fetch(Object, Slot, Filler, [Object], _),
  86.     Filler < Value.
  87.  
  88. /* case 5a: instead of 'Foo is in class Bar' we say 'Foo instance_of Bar' */
  89. prove(X instance_of Y,D) :-
  90.     !,
  91.     X instance_of Y with _. /* simple pattern-match in database, ignore _ */
  92. /* case 5b: analogous to case 5a, but this time for subclass_of */
  93. prove(X subclass_of Y,D) :-
  94.     !,
  95.     X subclass_of Y with _. /* simple pattern-match in database, ignore _ */
  96.  
  97. /* case 6: allow the system to ask the user for a value.  This may also
  98. be used to check a value, if you specify one.  If the user
  99. specifies values and the value doesn't match with the one
  100. the user gives at query-time, the goal will fail. */
  101. prove((query X),D):-
  102.     query X.
  103.  
  104. /* case 7: check that the thing is not already in working memory.  This
  105.     would be the case of, say, an unstructured fact eg. [kettle,on] */
  106. prove(WME,_):-
  107.     in_wm(WME).  /* N.B. the code for in_wm(WME) now handles case 3, too,
  108.                  namely frame access of the form: the X of Y is Z */
  109.  
  110. /* case 8: retrieve backward chaining rule from database, and prove premises.
  111.  N.B. only a single conclusion is allowed in rule (i.e. Horn clause form) */
  112. prove(Conc,D) :-
  113.     (rule Name backward if Premise then Conc),  /* single conclusion only!!! */
  114.  D1 is D + 1,                        /* increase depth for recursive proof */
  115.  when_enabled('show chosen rule' for  /* optional trace display */
  116.                [(rule Name backward if Premise then Conc)]),
  117.     prove1(Premise,D1).                 /* recursive proof of premise(s) */
  118.  
  119. /* =============== (2) F R A M E    M A N I P U L A T I O N ============= */
  120.  
  121. /* fetch is the main frame-traversal utility.
  122.  Fourth argument is a 'history list' to perform cycle detection
  123.  Fifth argument tells us where recursive lookup terminates,
  124.  i.e. from which ultimate object the property has been inherited, which could
  125.  be useful for fancier implementation, to reveal that, say,
  126.  the filler of slot FOO was inherited from class BAR.
  127.  Most of the work is done by contains, described below */
  128.  
  129. fetch(Object, Attribute, Value, History, TerminalObject) :-
  130.     (Object instance_of Class with Body), /* get from DB */
  131.     traverse_body(Object,Body,Attribute,
  132.                slot(value(V),inheritance(I),cardinality(C))), /* arg 3 is OUTPUT here */
  133.     ((I=[supersede];I=supersede),not(V=[]),!,'pd624 member'(Value,V) ;
  134.          'pd624 member'(Value,V)). /* fall through to next clause on btrack */
  135.     
  136. fetch(Object, Attribute, Value, History, TerminalObject) :-
  137.     (Object subclass_of Class with Body), /* alternative way to get it */
  138.     traverse_body(Object,Body,Attribute,
  139.                slot(value(V),inheritance(I),cardinality(C))), /* arg 3 OUTPUT here */
  140.     ((I=[supersede];I=supersede),not(V=[]),!,'pd624 member'(Value,V) ;
  141.          'pd624 member'(Value,V)). /* fall through to next clause on btrack */
  142.  
  143. fetch(Object,Attribute,Value,CycleList,TerminalNode):-
  144.     isa_linked(Object,Super), /* search up class links */
  145.     \+ 'pd624 member'(Super, CycleList), /* loop detector */
  146.     fetch(Super,Attribute,Value,[Super|CycleList],TerminalNode).
  147.  
  148. fetch1(Object,Attribute,Value,_,Object):-
  149.     (Object instance_of Class with Body),
  150.     contains(Body,Attribute:Value).
  151.  
  152. fetch1(Object,Attribute,Value,_,Object):-
  153.     (Object subclass_of Class with Body),
  154.     contains(Body,Attribute:Value).
  155.  
  156. fetch1(Object,Attribute,Value,CycleList,TerminalNode):-
  157.     isa_linked(Object,Super),
  158.     \+ 'pd624 member'(Super,CycleList),
  159.     fetch1(Super,Attribute,Value,[Super|CycleList],TerminalNode).
  160.  
  161. /* store/3 adds new slot-filler info at run time
  162.  COMPATIBILITY NOTE: Be sure that the object definitions are INTERPRETED in
  163.  MacPROLOG, or DYNAMIC in Quintus Prolog, so that the database can be updated
  164.  correctly */
  165. store(Object, Attribute, NewValue) :-
  166.  var(NewValue),
  167.  'pd624 write'(['ERROR: Illegal use of frames.  You are not allowed to'
  168.  ,nl,'have a variable as a frame slot filler.',nl,
  169.  'You tried to note the ',Attribute,' of ',Object,' is a variable. ',nl,
  170.  '*** FRAME ',Object,' NOT UPDATED ***',nl]),!.
  171.  store(Object, Attribute, NewValue) :-    (Object
  172.  instance_of Class with Body),     !,     subst(Object,(Attribute:Old),
  173.  (Attribute:NewValue), Body, NewBody),     retract((Object
  174.  instance_of Class with Body1)),     assert((Object instance_of
  175.  Class with NewBody)),
  176.  if_added_demon_check(NewBody,Object,Attribute,NewValue,Class).
  177.  store(Object, Attribute, NewValue) :-    (Object subclass_of Class
  178.  with Body),     !,     subst(Object,(Attribute:Old),
  179.  (Attribute:NewValue), Body, NewBody),     retract((Object
  180.  subclass_of Class with Body1)), assert((Object subclass_of Class
  181.  with NewBody)),
  182.  if_added_demon_check(NewBody,Object,Attribute,NewValue,Class).
  183.  store(Object, Attribute, NewValue) :-    assert((Object instance_of
  184.  'Newly Created Object'                                 with
  185.  Attribute:NewValue)).
  186.  
  187. if_added_demon_check(NewBody,Object,A,V,C):-
  188.   'pd624 cmember'(A:Body,NewBody),
  189.   if_added_demon(Body,Object,A,V,C).
  190. if_added_demon_check(NewBody,Object,A,V,C):-
  191.   if_added_demon([],Object,A,V,C).
  192.  
  193. /* subst: slot-filler substitution
  194. Args are as follows:
  195. 1: (input) object for ?self substitution
  196. 2: (input) old slot:filler combo we want over-written
  197. 3: (input) new slot:filler combo we want in place of oldie
  198. 4: (input) 'Body' of the frame, typically a long conjunct ...,...,...,...
  199. 5: (ouput) 'NewBody', i.e. the old Body with new stuff replacing old
  200. */
  201. subst(Object,Attribute:_, Attribute:New, (Attribute:[H|T],Rest),
  202.                                                          (Attribute:NewList,Rest)):-
  203.         subst_facet(Attribute:New,[H|T],[H|T],NewList,Object).
  204. subst(Object,Attribute:_, Attribute:New, Attribute:[H|T],
  205.                                                          Attribute:NewList):-
  206.         subst_facet(Attribute:New,[H|T],[H|T],NewList,Object).
  207.  
  208.  
  209. subst(Object,Attribute:Old, Attribute:New, Attribute:Old, Attribute:New):-
  210.     type_check([],Object,Attribute,New),
  211.     cardinality_check([],Object,Attribute,New).
  212.  
  213. subst(Object,Attribute1:Old1, Attribute:New, Attribute2:Old2,
  214. (Attribute2:Old2,Attribute:New)):-
  215.     type_check([],Object,Attribute,New),
  216.     cardinality_check([],Object,Attribute,New).
  217.  
  218. subst(Object,Attribute:Old, Attribute:New, (Attribute:Old,Rest),                             
  219. (Attribute:New,Rest)):-
  220.     type_check([],Object,Attribute,New),
  221.     cardinality_check([],Object,Attribute,New).
  222.  
  223. subst(Object,X,Y, (First,Rest), (First,NewRest)) :-
  224.     subst(Object,X,Y,Rest,NewRest).
  225.  
  226. /* substitute facet assumes that you can only change the value of an individual
  227. facet, not other facets like cardinality or type, which CANNOT be changed
  228. dynamically.  The substitue does a change as opposed to an add, i.e.
  229. existing value(s) are destructively replaced.  There is as yet no
  230. additional flag to AUGMENT an existing set of values, although
  231. section 4.2.2 of the MIKE reference manual shows how to accomplish this. */
  232.  
  233. /* variables A:V typically refer to Attribute:Value, which we tend
  234. to use synomynously with Slot:Filler */
  235.  
  236. subst_facet(A:V,Body,[value:V|Rest],[value:V|Rest],Object):-
  237.     type_check(Body,Object,A,V),
  238.     cardinality_check(Body,Object,A,V).
  239. subst_facet(A:V,Body,[value:V1|Rest],[value:V|Rest],Object):-
  240.     type_check(Body,Object,A,V),
  241.     cardinality_check(Body,Object,A,V).
  242. subst_facet(A:V,B,[H|Rest],[H|Output],Object):-
  243.     subst_facet(A:V,B,Rest,Output,Object).
  244.  
  245. /* searching up 'isa' chain can either involve 'instance_of' or
  246.      alternatively 'subclass_of' */
  247. isa_linked(X, Y) :-
  248.     X instance_of Y with _ .
  249. isa_linked(X, Y) :-
  250.     X subclass_of Y with _ .
  251.  
  252. /* ---------- c o n t a i n s ---------------------------
  253. this searches down the (usually compound) 'Body', looking for a
  254. slot:filler combination.  For example, suppose that we're looking for
  255. age:34 in some particular frame.  By the time contains/2 is invoked
  256. (by fetch), we don't care what particular frame we're examining,
  257. but instead are looking in detail at the 'Body' of that frame, e.g.
  258.       contains((has: fleas, eats: meat, age: 34),  age:34)
  259. We therefore have to do 2 things...
  260.     a) 'traverse' the body, CDR'ing down the line until we're at
  261. the right slot,
  262.     b) see whether we can reconcile the goods we actually found with the
  263. slot:filler combination we set out to find.
  264. The magic is that when we have found the relevant slot, we ALSO
  265. want to convert it to what we call "NormalFacetForm" to avoid
  266. the problem arising from three different ways of specifying
  267. frames (e.g. simple, compound, complex).  Therefore, when we find
  268. the relevant slot we invoke a workhorse called 'compose' which
  269. takes in a particular term and transforms it into our so-called
  270. NormalFacetForm.
  271. Thus there are only two calls to invoke:
  272. */
  273. contains(Body, Slot:Filler) :- /* Body & Slot normally input, Filler output */
  274.     traverse_body(Body,Slot,NormalFacetForm),
  275.     reconcilable(NormalFacetForm,Filler).
  276.  
  277. /* --------- t r a v e r s e - b o d y -------------------------
  278. This 'CDRs' down the compound body looking for a match of slot names,
  279. and (more importantly) invokes compose/2, which
  280. takes in a particular term and transforms it into our so-called
  281. NormalFacetForm, so that we dont have to sweat about which way
  282. the user happened to specify the contents of a
  283. frame (e.g. simple, compound, complex).
  284. */
  285.  
  286. /* case 1a: just a single slot, and it is the one we want */
  287. traverse_body(Object,Slot:Term,Slot,NormalFacetForm) :-
  288.     !,
  289.     compose(Object,Term, NormalFacetForm).
  290. traverse_body(Object,Slot:Term1,Slot1,NormalFacetForm) :-
  291.     if_needed(Object,Object,Slot1,Term),
  292.     compose(Object,Term,NormalFacetForm), !.
  293. /* case 2: a conjunction of slots, and first one is the one we want */
  294. traverse_body(Object,(Slot:Term, Rest), Slot, NormalFacetForm) :-
  295.     compose(Object,Term, NormalFacetForm),
  296.     !.
  297. /* case 3: a conjunction of slots, so we CDR on down the line */
  298. traverse_body(Object,(_, Rest), Slot, NormalFacetForm) :-
  299.     traverse_body(Object,Rest, Slot, NormalFacetForm).
  300.  
  301. /* -------------- c o m p o s e ------------------------------
  302. This is where we suffer for letting the user specify frames
  303. in any of three different ways.  compose/2 takes its first frame's argument
  304. (a typical filler) as input, and converts into a 'normalised' form.
  305. For consistency, unitary values are always converted to a 1-element
  306. list, so that the value facet is ALWAYS a list.
  307. Here are some input/ouput examples, wherein IN is always the
  308. first argument to compose, and OUT is always the second
  309. argument:
  310.  
  311. IN: meat
  312. OUT: slot(value([meat]), inheritance(supersede), cardinality(any))
  313.  
  314. IN: [meat, bread]
  315. OUT: slot(value([meat, bread]), inheritance(supersede),
  316. cardinality(any))
  317.  
  318. IN: [value: cheese, inheritance: merge, cardinality: 4]
  319. OUT: slot(value([cheese]), inheritance(merge), cardinality(4))
  320.  
  321. Now, for the code...
  322.  
  323. case 1: 'simple'
  324. this is an atomic filler, so just whack it into the value facet
  325. */
  326.  
  327. compose(Object,X, slot(value([X]), inheritance(supersede),
  328.                        cardinality(any))) :-
  329.     atomic(X),
  330.     !.
  331.  
  332. /* case 2: 'compound'
  333. this is a list of atomic fillers, e.g. [meat, potatoes], so do the
  334. same */
  335. compose(Object,[A|B], slot(value([A|B]),
  336.                            inheritance(supersede),
  337.                            cardinality(any))) :-
  338.     atomic(A),
  339.     !.
  340.  
  341. /* case 3: 'complex'
  342. to get this far, the fillers must be in the complex form
  343. of [<facetX.Y>:<filler>, etc.], so we work through the list separately
  344. for each of our important facets, using a workhorse utility called
  345. force_membership which either finds the relevant item, or shoves
  346. the default value (e.g. 'supersede' for inheritance) in the right place
  347. */
  348. compose(Object,FacetFillerList, slot(value(V), inheritance(I),
  349.                                      cardinality(C))) :-
  350.     force_membership(Object,value : V, FacetFillerList),
  351.     force_membership(Object,inheritance : I, FacetFillerList),
  352.     force_membership(Object,cardinality : C, FacetFillerList).
  353.  
  354. /* --------- f o r c e - m e m b e r s h i p ------------------
  355. arg1 is OUTPUT, arg2 INPUT
  356. */
  357. /* first check the value --- if the value is absent or unknown
  358.    then look to see if there is an if_needed (access rule) demon */
  359. force_membership(Object,value: V,List):-
  360.     \+ 'pd624 member'(value:V,List),
  361.     if_needed1(Object,value:V,List).
  362. force_membership(Object,value: V,List):-
  363.     ( 'pd624 member'(value: unknown,List); 'pd624 member'(value : [], List)),
  364.     if_needed1(Object,value:V,List).
  365. /* compund (set of) fillers? then put them all in the facet */
  366. force_membership(Object,Facet : [Filler|Fillers], List) :-
  367.     'pd624 member'(Facet : [Filler|Fillers], List),
  368.     !.
  369. /* unitary filler? then put it into a one-element list [Filler] */
  370. force_membership(Object,Facet : [Filler], List) :-
  371.     'pd624 member'(Facet : Filler, List),
  372.     !.
  373.  
  374. /* to get here, we must not have found anything, so we impose
  375. ('force') a default filler on the relevant facet, according to the
  376. name of the facet.  e.g. if it is 'inheritance', we force 'supersede',
  377. if it is 'type', we force 'any', if it is 'value', we force '[]' */
  378.  
  379. force_membership(Object,inheritance: [supersede], List) :- !.
  380. force_membership(Object,type: any, List) :- !.
  381. force_membership(Object,cardinality: any, List) :- !.
  382. /* all other facets, such as 'value', default to an empty list */
  383. force_membership(Object,Facet : [], List).
  384.  
  385. /* ---------------- r e c o n c i l a b l e ----------------------
  386. having found our actual frame contents, now we really need to know
  387. whether the given Filler is consistent with the current value
  388. (remember that since we have converted to NormalFacetForm,
  389. the variable V below will always be a list.
  390. For now, we just use a membership test, but fancier options are
  391. possible, such as checking for consistency, looking for counter-
  392. examples, etc.
  393. Notice 4th argument (output) is used as a flag to pass back the
  394. type of inheritance mechanism */
  395.  
  396. reconcilable(slot(value(V), inheritance(I), cardinality(C)),
  397.                     Filler  ) :-
  398.     'pd624 member'(Filler,V).
  399.  
  400.  
  401. /* ----------------- Type and Cardinality checking --------------------
  402.   (a) cardinality must be defined by number, or a range in the form
  403.       LowerBound-HigherBound.  The arguments ARE ORDER SENSITIVE!
  404.   (b) type checking is only done for a particular slot in
  405.       which the value is located. */
  406.  
  407. type_check(Body,Object,Attribute,Value):-
  408.    'pd624 member'(type : T,Body),!,
  409.     type_consistency(T,Object,Attribute,Value).
  410. type_check(_,Object,Attribute,Value):-
  411.     isa_tc_check(Object,Object,type,Attribute,Value).
  412. type_check(_,_,_,_).
  413. cardinality_check(Body,Object,Attribute,Value):-
  414.    'pd624 member'(cardinality : C,Body),  !,
  415.    cardinality_consistency(C,Object,Attribute,Value).
  416. cardinality_check(_,Object,Attribute,Value):-
  417.    isa_tc_check(Object,Object,cardinality,Attribute,Value).
  418. cardinality_check(_,_,_,_).
  419.  
  420. /* recursive checking up isa hierarchy */
  421. isa_tc_check(Thing,Original,Flag,Attribute,Value):-
  422.    isa_linked(Thing,Parent),
  423.    (Parent subclass_of _ with Body),
  424.    'pd624 cmember'(Attribute:List,Body),
  425.    'pd624 member'(Flag:Check,List),
  426.    choose_test(Flag,Check,Parent,Attribute,Value),!.
  427. isa_tc_check(Thing,Original,Flag,Attribute,Value):-
  428.    isa_linked(Thing,Parent),
  429.    (Parent instance_of _ with Body),
  430.    'pd624 cmember'(Attribute:List,Body),
  431.    'pd624 member'(Flag:Check,List),
  432.    choose_test(Flag,Check,Parent,Attribute,Value),!.
  433.  
  434. isa_tc_check(Thing,Original,Flag,Attribute,Value):-
  435.    isa_linked(Thing,Parent),
  436.    isa_tc_check(Parent,Original,Flag,Attribute,Value).
  437. isa_tc_check(_,_,_,_,_). /* so it always wins */
  438.  
  439. choose_test(type,Check,Object,Attribute,Value):-
  440.    type_consistency(Check,Object,Attribute,Value).
  441. choose_test(cardinality,Check,Object,Attribute,Value):-
  442.    cardinality_consistency(Check,Object,Attribute,Value).
  443.  
  444. /* any is the default case so for efficiency let's check for it first */
  445. type_consistency(any,_,_,_):- !.
  446. type_consistency(A,_,_,V):-
  447.     isa_linked(V,A).
  448. type_consistency(A,_,_,V):-
  449.     isa_linked(V,Something),
  450.     type_consistency(A,_,_,Something).
  451. type_consistency(integer,_,_,V):-
  452.     integer(V),!.
  453. type_consistency(nonvar,_,_,V):-
  454.     nonvar(V),!.
  455. type_consistency(atom,_,_,V):-
  456.     atomic(V),!.
  457. type_consistency(list,_,_,[H|T]).
  458. type_consistency(list,_,_,[]).
  459. type_consistency(Alternatives,_,_,V):-
  460.    'pd624 member'(V,Alternatives),!.
  461. type_consistency(T,Object,Attribute,Value):-
  462.     'pd624 write'(['Warning: "',Value,
  463.     '" violates the "type" facet of "',Object,'" for slot "',Attribute,
  464.     '" ',
  465.     nl,'which specifies type : ',T,'. ',
  466.     nl,'(but proceeding anyway)',nl]),!.
  467.  
  468. /* the default cardinality is 'any'.  As this will probably occur more
  469.    often than any other case, for efficiency check for it first */
  470. cardinality_consistency(any,_,_,_).
  471. cardinality_consistency(1,Object,Attribute,Value):- /* cardinality one,
  472.    then check to see if the slot filler is atomic */
  473.    atomic(Value).
  474. cardinality_consistency(A-B,Object,Attribute,Value):-
  475.     'pd624 list length'(Value,Length),
  476.     Length >= A,
  477.     Length =< B.
  478. cardinality_consistency(Num,Object,Attribute,Value):-
  479.    'pd624 list length'(Value,Num). /* this will also cater for list of
  480.       length one should they exist for some perverse reason */
  481. cardinality_consistency(Number,Object,Attribute,Value):-
  482.    'pd624 write'(['Warning: "',Value,'" violates the "cardinality" facet of "',
  483.     Object,'" for slot "',Attribute,'"',nl,
  484.     'which specifies cardinality : ',Number,'. ',nl,
  485.     '(but proceeding anyway)',nl]).
  486.  
  487.  
  488. /* =================== (3) D E M O N   P R O C E S S I N G ============ */
  489. /* if_added demons are 'change_rules' in the text
  490.    if_needed are called 'access_rules' */
  491.  
  492. if_added_demon(Body,Object,A,V,Parent):-
  493.     'pd624 member'(change_rule : What_to_do,Body),
  494.     process_if_added(What_to_do,Object,A).
  495.  
  496. if_added_demon(Body,Object,Attr,Val,Parent):-
  497.     find_the_superior_body(Parent,New_body),
  498.     'pd624 cmember'(Attr:ABody,New_body),
  499.     'pd624 member'(change_rule : Method,ABody),!,
  500.     unify_value(Val,ABody),
  501.     process_if_added(Method,Object,Attr).
  502. if_added_demon(Body,Object,Attr,Val,Parent):-
  503.     isa_linked(Parent,Super_parent),
  504.  if_added_demon(Body,Object,Attr,Val,Super_parent).
  505. if_added_demon(B,O,A,V,P).
  506.  
  507. unify_value(Value,Body):-
  508.     'pd624 member'(value:Value,Body).
  509. unify_value(A,B). /* when the two will not unify */
  510.  
  511. find_the_superior_body(Object,Body):-
  512.     (Object instance_of _ with Body).
  513. find_the_superior_body(Object,Body):-
  514.  (Object subclass_of _whoever with Body).
  515.  
  516. 'pd624 cmember'(A,(A,_)).
  517. 'pd624 cmember'(A,(_,Rest)):-
  518.      'pd624 cmember'(A,Rest).
  519. 'pd624 cmember'(A,A).
  520.  
  521. process_if_added(Method,Object,Attr):-
  522.     process_method(Method,Object,Attr).
  523. process_if_added(Method,Object,Attr):-
  524.     write('WARNING... The following method failed: '),write(Method),nl,
  525.     write('from the object frame '),write(Object),nl.
  526.  
  527.  
  528. if_in_wm(A or B,Obj):-
  529.     if_in_wm(A,Obj), !.
  530. if_in_wm(_ or B,Obj):-
  531.     if_in_wm(B,Obj), !.
  532. if_in_wm(Pattern1 & Rest,Obj) :-
  533.     !,
  534.     if_in_wm(Pattern1,Obj),
  535.     if_in_wm(Rest,Obj).
  536. if_in_wm(the Attr of ?self is What,Object):-
  537.  in_wm(the Attr of Object is What).
  538. if_in_wm(true,_).
  539. if_in_wm(Pattern,_) :- /*singleton*/
  540.     in_wm(Pattern).
  541.  
  542. process_method((if Ifs then Thens),Object,Attr):-
  543.    'pd624 replace'(?self,Object,Ifs,NewIfs),
  544.    if_in_wm(NewIfs,Object),
  545.    parse_first(Thens,Object,Attr).
  546.  
  547. parse_first(A & B,Object,Attribute):-
  548.    parse_first(A,Object,Attribute),!,
  549.    parse_first(B,Object,Attribute).
  550.  
  551. /* PATCH 7th. September 1990.
  552. the following makes the consequences of if added demons consistent
  553. with that of forward chaining rules.  Instead of the previous limitation
  554. regarding the use of ?self which was limited to the pattern
  555. the X of ?self is Y, ?self can now be used arbitrarily in a pattern
  556. e.g. [likes, ?self, beer] or loves(?self,mary).  */
  557.  
  558. parse_first(Term,Object,A):-
  559.    'pd624 replace'(?self,Object,Term,NTerm),
  560.    perform1(NTerm,_,_,_).
  561.  
  562. /* ---------------- COMPATIBILITY NOTE -------------------------
  563. In the next two predicate definitions, we test for
  564.    real(Term)
  565. If your dialect of Prolog does not cater for real numbers,
  566. you can comment out those tests
  567. ---------------------------------------------------------------- */
  568.  
  569. 'pd624 replace'(O,N,O1,O1):- var(O1),!.
  570. 'pd624 replace'(O,N,O,N).
  571. 'pd624 replace'(Old,New,Term,Term) :-
  572.   (integer(Term) ; real(Term) ; atom(Term)),
  573.   not(Term=Old).
  574. 'pd624 replace'(Old,New,Term,Term1) :-
  575.   'pd624 compound'(Term),
  576.   functor(Term,F,N),
  577.   functor(Term1,F,N),
  578.   'pd624 replace'(N,Old,New,Term,Term1).
  579. 'pd624 replace'(N,Old,New,Term,Term1) :-
  580.   N>0,
  581.   arg(N,Term,Arg),
  582.   'pd624 replace'(Old,New,Arg,Arg1),
  583.   arg(N,Term1,Arg1),
  584.   N1 is N-1,
  585.   'pd624 replace'(N1,Old,New,Term,Term1).
  586. 'pd624 replace'(0,Old,New,Term,Term1).
  587.  
  588. 'pd624 compound'(X) :-
  589.    not(atom(X)),
  590.    not(real(X)),     /* see above compatibility notice */
  591.    not(integer(X)).
  592.  
  593. decide_what_to_store(the Attribute of Object is Value):-
  594.     store(Object,Attribute,Value).
  595. decide_what_to_store(_).  /* to cater for unstructured facts */
  596.  
  597. /* the output is always a list */
  598. find_value((if Ifs then Thens),Object,Attribute,Value):-
  599.   demon_prove(Ifs,Object,Attribute),
  600.   demon_rhs(Thens,Object,Attribute,Value).
  601.  
  602. demon_prove(X or Y,Object,Attribute):-
  603.   demon_prove(X,Object,Attribute);
  604.   demon_prove(Y,Object,Attribute),!.
  605. demon_prove(X & Y,Object,Attribute):-
  606.   demon_prove(X,Object,Attribute),
  607.   demon_prove(Y,Object,Attribute).
  608. demon_prove(true,_,_). /* for lhs of the form if true then Then */
  609. demon_prove(the Attribute of Object is What,Object,Attribute):-
  610.   'pd624 write'(['Error: the ',Attribute,' of ',Object,
  611.    ' is being re-invoked in the very demon that is trying to find',nl,
  612.    'its value.  This request will cause the method to fail',nl]).
  613. demon_prove(the Attribute of ?self is What,Object,Attribute):-
  614.   'pd624 write'(['Error: the ',Attribute,' of ',Object,
  615.    ' is being re-invoked in the very demon that is trying to find',nl,
  616.    'its value.  This request will be cause the method to fail',nl]).
  617.  
  618. demon_prove(the A of ?self is What,Object,_):-
  619.    prove(the A of Object is What).
  620. demon_prove(X,_,_) :- prove(X).
  621.  
  622. demon_rhs(the A of B is C,_,_,C):- /* PATCH 7/9/90 */
  623.    !.  /* i.e. do nothing, because C is simply returned un-cached */
  624. demon_rhs(make_value X,Object,Attribute,X):-
  625.    !,
  626.    note the Attribute of Object is X.
  627. demon_rhs(A,B,C,_):-
  628. 'pd624 write'(['Warning: the access_rule method for ',B,' of  ',C,
  629.   'contains a right-hand-side which does not supply a value.',nl,
  630.   'Right-hand-sides that do must be of the form the A of B is C',
  631.   'or they must contain the key-word "make_value" followed by a value.',
  632.   nl]),!.
  633.  
  634. list_check([P|P1],[P|P1]).
  635. list_check(P,[P]).
  636.  
  637. /* this only gets called when we know we have a demon in the current
  638.    facet filler, in which case we don't go chasing up the isa chain */
  639. if_needed1(Object,value:Value,Body):-
  640.     'pd624 member'((access_rule : What_to_do),Body),
  641.     find_value(What_to_do,Object,' this is a dummy value to pass ',Value).
  642.  
  643. /* the standard case.  You don't find a value so you try going up the
  644.    isa chain in order to find an appropriate demon at some stage in
  645.    your ancestry */
  646. if_needed(BaseObject,Object,Slot,Term):-
  647.        (Object instance_of Super with _),
  648.     find_the_superior_body(Super,NewBody),
  649.     if_needed_process(BaseObject,Slot,Term,Super,NewBody).
  650. if_needed(BaseObject,Object,Slot,Term):-
  651.     (Object subclass_of Super with _),
  652.     find_the_superior_body(Super,NewBody),
  653.     if_needed_process(BaseObject,Slot,Term,Super,NewBody).
  654. if_needed(BaseObject,Object,Slot,Term):-
  655.     (Object subclass_of Super with _),
  656.     if_needed(BaseObject,Super,Slot,Term).
  657. if_needed(BaseObject,Object,Slot,Term):-
  658.     (Object instance_of Super with _),
  659.     if_needed(BaseObject,Super,Slot,Term).
  660.  
  661. if_needed_process(BaseObject,Attr,Val,Super,Body):-
  662.     'pd624 cmember'(Attr:ABody,Body),
  663.     'pd624 member'(access_rule:Method,ABody),
  664.     !,
  665.     (find_value(Method,BaseObject,Attr,Val);
  666.      write('WARNING... The following access_rule demon failed: '),nl,
  667.     write(Method),nl,write('In the frame '),write(Super),nl,!,fail).
  668.  
  669. /* more forward chaining code is in file ENGINE2.PL */